home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / libs / phigs / ptk.lha / ptk / fortran / source / library / menu.f < prev    next >
Encoding:
Text File  |  1992-06-18  |  27.3 KB  |  812 lines
  1. C----------------------------------------------------------------------------
  2.  
  3. C Module name: PHIGS menus utility
  4.  
  5. C Author: Karen Wyrwas
  6.  
  7. C Function: This module contains the PHIGS utility routines
  8. C for menus and high level input tools. They are all built on top of PHIGS.
  9.  
  10. C Hashtables used: "structureid", "name", "label".
  11.  
  12. C Modification history: (Version), (Date), (Name), (Description).
  13.  
  14. C 1.0, 9th March 1988, Karen Wyrwas, First version.
  15.  
  16. C 1.1, 31st October 1988, Karen Wyrwas, Add rotator routines.
  17.  
  18. C 1.2, 1st November 1988, Karen Wyrwas, Port to VAX PHIGS.
  19.  
  20. C 2.0, 25th April 1991, Gareth Williams, Translated to C.
  21.  
  22. C 2.1, 16th May 1991, Gareth Williams, Functions getmenu, getmenuid,
  23. C disposemenus, ptk_inqpickmenus added.
  24.  
  25. C 2.2, 23rd May 1991, Gareth Williams, Built rotators on top of user menus.
  26.  
  27. C---------------------------------------------------------------------------
  28.  
  29.        SUBROUTINE ptkf_createusermenu(menuid, menustid)
  30. C /*
  31. C ** \parambegin
  32. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  33. C ** \param{INTEGER}{menustid}{menu structure identifier}{IN}
  34. C ** \paramend
  35. C ** \blurb{This function creates a user menu using the structure
  36. C ** {\tt menustid}. Each menu item must be an individual PHIGS
  37. C ** structure or network and the menu initially contains no menu items.}
  38. C */
  39.        INTEGER menuid, menustid
  40.        external ptk_createusermenu !$PRAGMA C(ptk_createusermenu)
  41.  
  42.        call ptk_createusermenu(%val(menuid), %val(menustid))
  43.  
  44.        RETURN
  45.        END
  46.  
  47.        SUBROUTINE ptkf_createboxmenu(menuid, tlcorner, boxsize)
  48. C /*
  49. C ** \parambegin
  50. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  51. C ** \param{REAL}{tlcorner(2)}{top left corner of menu}{IN}
  52. C ** \param{REAL}{boxsize(2)}{width and height of menu box item}{IN}
  53. C ** \paramend
  54. C ** \blurb{This function creates a box menu with no initial items.
  55. C ** The position of the menu is specified by {\tt tlcorner} which
  56. C ** defines the top-left corner of the first menu item. The position
  57. C ** and size of box menu items are given in the range [0, 1]. The default
  58. C ** menu path is DOWN.}
  59. C */
  60.        INTEGER menuid
  61.        REAL tlcorner(3), boxsize(2)
  62.        external ptk_createboxmenu !$PRAGMA C(ptk_createboxmenu)
  63.  
  64.        call ptk_createboxmenu(%val(menuid), tlcorner, boxsize)
  65.  
  66.        RETURN
  67.        END
  68.        
  69.        SUBROUTINE ptkf_createtextmenuitem(menuid, str, itemno,
  70. & editmode, error)
  71. C /*
  72. C ** \parambegin
  73. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  74. C ** \param{CHARACTER*(*)}{str}{text string}{IN}
  75. C ** \param{INTEGER}{itemno}{menu item number}{IN}
  76. C ** \param{INTEGER}{editmode}{insert or replace menu item.}{IN}
  77. C ** \param{INTEGER}{error}{error code}{IN}
  78. C ** \paramend
  79. C ** \blurb{This function creates a box menu item containing the character
  80. C ** string {\tt str}. The string is automatically scaled to fit inside
  81. C ** the menu item box. This function may only be used with box menus.}
  82. C ** 
  83. C */
  84.        INTEGER menuid
  85.        CHARACTER*(*) str
  86.        INTEGER itemno, editmode, error
  87.        CHARACTER*255 inbuf
  88.        external ptk_createtextmenuitem 
  89. & !$PRAGMA C(ptk_createtextmenuitem)
  90.  
  91.        inbuf = str//'\0'
  92.        call ptk_createtextmenuitem(%val(menuid), str, %val(itemno),
  93. &  %val(editmode), error)
  94.  
  95.        RETURN
  96.        END
  97.        
  98.        SUBROUTINE ptkf_createstructmenuitem(menuid, structid, itemno, 
  99. & editmode, error)
  100. C /*
  101. C ** \parambegin
  102. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  103. C ** \param{INTEGER}{structid}{menu item structure identifier}{IN}
  104. C ** \param{INTEGER}{itemno}{menu item number}{IN}
  105. C ** \param{INTEGER}{editmode}{insert or replace menu item}{IN}
  106. C ** \param{INTEGER}{error}{error code}{IN}
  107. C ** \paramend
  108. C ** \blurb{This function creates a menu item defined by {\tt structure}.
  109. C ** In the case of box menus the structure is mapped into the item box
  110. C ** with aspect ratio preserved. No transformation is applied for user
  111. C ** menu items.}
  112. C */
  113.        INTEGER menuid, structid
  114.        INTEGER itemno, editmode, error
  115.        external ptk_createstructmenuitem 
  116. & !$PRAGMA C(ptk_createstructmenuitem)
  117.  
  118.        call  ptk_createstructmenuitem(%val(menuid), %val(structid), 
  119. & %val(itemno), %val(editmode), error)
  120.  
  121.        RETURN
  122.        END
  123.        
  124.        LOGICAL FUNCTION ptkf_delmenu(menuid)
  125. C /*
  126. C ** \parambegin
  127. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  128. C ** \paramend
  129. C ** \blurb{This function deletes a menu from the PHIGS Toolkit menu store.
  130. C ** The function returns TRUE if {\tt menuid} is deleted, otherwise FALSE.}
  131. C */
  132.        INTEGER menuid
  133.        LOGICAL*1 ptk_delmenu, ans
  134.        external ptk_delmenu !$PRAGMA C(ptk_delmenu)
  135.  
  136.        ans = ptk_delmenu(%val(menuid))
  137.        if (ans .eq. 1) then
  138.           ptkf_delmenu = .TRUE.
  139.        else
  140.           ptkf_delmenu = .FALSE.
  141.        endif
  142.  
  143.        RETURN
  144.        END
  145.        
  146.        LOGICAL FUNCTION ptkf_delmenuitem(menuid, itemno)
  147. C /*
  148. C ** \parambegin
  149. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  150. C ** \param{INTEGER}{itemno}{menu item to delete}{IN}
  151. C ** \paramend
  152. C ** \blurb{This function deletes the menu item {\tt itemno}.
  153. C ** The function returns TRUE if the menu item is deleted, otherwise FALSE.}
  154. C */
  155.        INTEGER menuid, itemno
  156.        LOGICAL*1 ptk_delmenuitem, ans
  157.        external ptk_delmenuitem !$PRAGMA C(ptk_delmenuitem)
  158.  
  159.        ans = ptk_delmenuitem(%val(menuid), %val(itemno))
  160.        if (ans .eq. 1) then
  161.           ptkf_delmenuitem = .TRUE.
  162.        else
  163.           ptkf_delmenuitem = .FALSE.
  164.        endif
  165.  
  166.        RETURN
  167.        END
  168.        
  169.        SUBROUTINE ptkf_frontmenu(wsid, menuid)
  170. C /*
  171. C ** \parambegin
  172. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  173. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  174. C ** \paramend 
  175. C ** \blurb{This function sets the post priority of the menu structure
  176. C ** so that it is displayed on top of all the other posted menus and
  177. C ** windows.}
  178. C */
  179.        INTEGER wsid, menuid
  180.        external ptk_frontmenu !$PRAGMA C(ptk_frontmenu)
  181.  
  182.        call ptk_frontmenu(%val(wsid), %val(menuid))
  183.        RETURN
  184.        END
  185.        
  186.        SUBROUTINE ptkf_backmenu(wsid, menuid)
  187. C /*
  188. C ** \parambegin
  189. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  190. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  191. C ** \paramend 
  192. C ** \blurb{This function sets the post priority of the menu structure so
  193. C ** that it is displayed below all other posted menus but in front of
  194. C ** all posted windows.}
  195. C */
  196.        INTEGER wsid, menuid
  197.        external ptk_backmenu !$PRAGMA C(ptk_backmenu)
  198.  
  199.        call ptk_backmenu(%val(wsid), %val(menuid))
  200.  
  201.        RETURN
  202.        END
  203.        
  204.        SUBROUTINE ptkf_postmenu(wsid, menuid)
  205. C /*
  206. C ** \parambegin
  207. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  208. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  209. C ** \paramend
  210. C ** \blurb{This function posts the menu structure to the workstation
  211. C ** {\tt wsid}. The priority of the menu structure is controlled by the
  212. C ** PHIGS Toolkit menu system to provide an ordered stacking of displayed
  213. C ** menus. When {\tt menuid} is posted it becomes the front menu.} 
  214. C */
  215.        INTEGER wsid, menuid
  216.        external ptk_postmenu !$PRAGMA C(ptk_postmenu)
  217.  
  218.        call ptk_postmenu(%val(wsid), %val(menuid))
  219.  
  220.        RETURN
  221.        END
  222.        
  223.        SUBROUTINE ptkf_unpostmenu(wsid, menuid)
  224. C /*
  225. C ** \parambegin
  226. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  227. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  228. C ** \paramend
  229. C ** \blurb{This function unposts a menu structure from the workstation
  230. C ** {\tt wsid}. The front and back menus are updated if necessary.}
  231. C */
  232.        INTEGER wsid, menuid
  233.        external ptk_unpostmenu !$PRAGMA C(ptk_unpostmenu)
  234.  
  235.        call ptk_unpostmenu(%val(wsid), %val(menuid))
  236.  
  237.        RETURN
  238.        END
  239.  
  240.        SUBROUTINE ptkf_unpostallmenu(wsid)
  241. C /*
  242. C ** \parambegin
  243. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  244. C ** \paramend
  245. C ** \blurb{This function unposts all menus from the workstation {\tt wsid}.}
  246. C */
  247.        INTEGER wsid
  248.        external ptk_unpostallmenu !$PRAGMA C(ptk_unpostallmenu)
  249.  
  250.        call ptk_unpostallmenu(%val(wsid))
  251.  
  252.        RETURN
  253.        END
  254.        
  255.        LOGICAL FUNCTION ptkf_stringscanmenus(wsid, str, menuid, itemnum)
  256. C /*
  257. C ** \parambegin
  258. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  259. C ** \param{CHARACTER*(*)}{str}{string}{IN}
  260. C ** \param{INTEGER}{menuid}{menu identifier}{OUT}
  261. C ** \param{INTEGER}{itemno}{item number}{OUT}
  262. C ** \paramend
  263. C ** \blurb{This function compares the character string {\tt str} with
  264. C ** the items of all posted menus. The comparison begins with the
  265. C ** highest priority menu and works through to the back menu.
  266. C ** User menu items are also searched for text primitives with which to
  267. C ** compare the string. The comparison is case sensitive so that
  268. C ** "item 1" is not the same as "IteM 1".
  269. C ** The function returns TRUE if the string matches a menu item, 
  270. C ** otherwise FALSE.}
  271. C */
  272.        INTEGER wsid
  273.        CHARACTER*(*) str
  274.        INTEGER menuid, itemnum
  275.        LOGICAL*1 ptk_stringscanmenus, ans
  276.        CHARACTER*255 inbuf
  277.        external ptk_stringscanmenus !$PRAGMA C(ptk_stringscanmenus)
  278.  
  279.        inbuf = str//'\0'
  280.        ans = ptk_stringscanmenus(%val(wsid), inbuf, menuid, itemnum)
  281.        if (ans .eq. 1) then
  282.           ptkf_stringscanmenus = .TRUE.
  283.        else
  284.           ptkf_stringscanmenus = .FALSE.
  285.        endif
  286.  
  287.        RETURN
  288.        END
  289.  
  290.        LOGICAL FUNCTION ptkf_pickscanmenus(ippd, pp, ppordr, menuid, 
  291. & itemnum)
  292. C /*
  293. C ** \parambegin
  294. C ** \param{INTEGER}{ippd}{depth of pick path}{IN}
  295. C ** \param{INTEGER}{pp(3, ippd)}{pick path through structure network.}{IN}
  296. C ** \param{INTEGER}{ppordr}{order of data in pickpath}{IN}
  297. C ** \param{INTEGER}{menuid}{menu identifier}{OUT}
  298. C ** \param{INTEGER}{itemnum}{item number}{OUT}
  299. C ** \paramend
  300. C ** \blurb{This function tests the pick path to inquire if a menu item
  301. C ** was picked. 
  302. C ** The function returns TRUE if a menu item was picked, otherwise FALSE.}
  303. C */
  304.        INTEGER ippd
  305.        INTEGER pp(3, ippd)
  306.        INTEGER ppordr
  307.        INTEGER menuid, itemnum
  308.        LOGICAL*1 ptkc_pickscanmenus, ans
  309.        external ptkc_pickscanmenus !$PRAGMA C(ptkc_pickscanmenus)
  310.  
  311.        ans = ptkc_pickscanmenus(%val(ippd), pp, %val(ppordr), menuid, 
  312. & itemnum)
  313.        if (ans .eq. 1) then
  314.           ptkf_pickscanmenus = .TRUE.
  315.        else
  316.           ptkf_pickscanmenus = .FALSE.
  317.        endif
  318.  
  319.        RETURN
  320.        END
  321.  
  322.        LOGICAL FUNCTION ptkf_locscanmenus(wsid, point, menuid, itemnum, 
  323. & value)
  324. C /*
  325. C ** \parambegin
  326. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  327. C ** \param{REAL}{point(2)}{input point}{IN}
  328. C ** \param{INTEGER}{menuid}{menu identifier}{OUT}
  329. C ** \param{INTEGER}{itemnum}{item number}{OUT}
  330. C ** \param{REAL}{value(2)}{position of point within item}{OUT}
  331. C ** \paramend
  332. C ** \blurb{This function uses the INCREMENTAL SPATIAL SEARCH function 
  333. C ** of PHIGS to test if {\tt point} lies within a posted menu.
  334. C ** The menus are tested begining the highest priority menu and working 
  335. C ** through to the back menu. The position of {\tt point} relative
  336. C ** to bottom-left corner of the menu item bounding box is returned
  337. C ** in {\tt value}.
  338. C ** The function returns TRUE if {\tt point} lies within a menu, 
  339. C ** otherwise FALSE.}
  340. C */
  341.        INTEGER wsid
  342.        REAL point(2)
  343.        INTEGER menuid, itemnum
  344.        REAL value(2)
  345.        LOGICAL*1 ptk_locscanmenus, ans
  346.        external ptk_locscanmenus !$PRAGMA C(ptk_locscanmenus)
  347.  
  348.        ans = ptk_locscanmenus(%val(wsid), point, menuid, itemnum, value)
  349.        if (ans .eq. 1) then
  350.           ptkf_locscanmenus = .TRUE.
  351.        else
  352.           ptkf_locscanmenus = .FALSE.
  353.        endif
  354.  
  355.        RETURN
  356.        END
  357.        
  358.        SUBROUTINE ptkf_setmenuposition(menuid, menupos)
  359. C /*
  360. C ** \parambegin
  361. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  362. C ** \param{REAL}{menupos(2)}{menu position}{IN}
  363. C ** \paramend
  364. C ** \blurb{This function sets the position of the top-left corner of the
  365. C ** first menu item. The position is given in the range [0, 1]. If the
  366. C ** position results in part of the menu being clipped then the actual
  367. C ** position is adjusted so that as much as possible of the menu is 
  368. C ** visible.}
  369. C */
  370.        INTEGER menuid
  371.        REAL menupos(2)
  372.        external ptk_setmenuposition !$PRAGMA C(ptk_setmenuposition)
  373.  
  374.        call ptk_setmenuposition(%val(menuid), menupos)
  375.  
  376.        RETURN
  377.        END
  378.        
  379.        SUBROUTINE ptkf_setboxmenutextfont(wsid, menuid, font)
  380. C /*
  381. C ** \parambegin
  382. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  383. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  384. C ** \param{INTEGER}{font}{text font}{IN}
  385. C ** \paramend
  386. C ** \blurb{This function sets the text font of all text menu items in the
  387. C ** menu structure. The menu must be a box menu.}
  388. C */
  389.        INTEGER wsid, menuid, font
  390.        external ptk_setboxmenutextfont 
  391. & !$PRAGMA C(ptk_setboxmenutextfont)
  392.  
  393.        call ptk_setboxmenutextfont(%val(wsid), %val(menuid), %val(font))
  394.  
  395.        RETURN
  396.        END
  397.  
  398.        SUBROUTINE ptkf_setboxmenuattrs(wsid, menuid, 
  399. & menupath, font, textcolour, intcolour, edgecolour, 
  400. & boxtlcolour, boxbrcolour, httextcolour, htintcolour, 
  401. & htedgecolour)
  402. C /*
  403. C ** \parambegin
  404. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  405. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  406. C ** \param{INTEGER}{menupath}{path of box menu (left, right, up, down)}{IN}
  407. C ** \param{INTEGER}{font}{text font}{IN}
  408. C ** \param{INTEGER}{textcolour}{colour index for text}{IN}
  409. C ** \param{INTEGER}{intcolour}{colour index for interior}{IN}
  410. C ** \param{INTEGER}{edgecolour}{colour index for edges}{IN}
  411. C ** \param{INTEGER}{boxtlcolour}{colour index for top-left of box}{IN}
  412. C ** \param{INTEGER}{boxcolour}{colour index for bottom-right of box}{IN}
  413. C ** \param{INTEGER}{httextcolour}{colour index for highlight text}{IN}
  414. C ** \param{INTEGER}{htintcolour}{colour index for highlight interior}{IN}
  415. C ** \param{INTEGER}{htedgecolour}{colour index for highlight edges}{IN}
  416. C ** \paramend
  417. C ** \blurb{This function sets the box menu path, text font and colour attribute
  418. C ** values. The highlight colour indicies are used by the function
  419. C ** {\tt ptk\_setboxmenuhighlightitem} to highlight a single menu item.}
  420. C */
  421.        INTEGER wsid, menuid, menupath, font
  422.        INTEGER textcolour, intcolour, edgecolour
  423.        INTEGER boxtlcolour, boxbrcolour
  424.        INTEGER httextcolour, htintcolour, htedgecolour
  425.        external ptk_setboxmenuattrs
  426. & !$PRAGMA C(ptk_setboxmenuattrs)
  427.  
  428.        call ptk_setboxmenuattrs(%val(wsid), %val(menuid), 
  429. & %val(menupath), %val(font), %val(textcolour), %val(intcolour), 
  430. & %val(edgecolour), %val(boxtlcolour), %val(boxbrcolour), 
  431. & %val(httextcolour), %val(htintcolour), %val(htedgecolour))
  432.  
  433.        RETURN
  434.        END
  435.        
  436.        SUBROUTINE ptkf_setboxmenuhighlightitem(menuid, itemnum)
  437. C /*
  438. C ** \parambegin
  439. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  440. C ** \param{INTEGER}{itemnum}{menu item number}{IN}
  441. C ** \paramend
  442. C ** \blurb{This function highlights a menu item by setting the colour
  443. C ** index values for the text, interior and edge of a box menu item.}
  444. C */
  445.        INTEGER menuid, itemnum
  446.        external ptk_setboxmenuhighlightitem 
  447. & !$PRAGMA  C(ptk_setboxmenuhighlightitem)
  448.  
  449.        call ptk_setboxmenuhighlightitem(%val(menuid), %val(itemnum))
  450.  
  451.        RETURN
  452.        END
  453.        
  454.        SUBROUTINE ptkf_clearboxmenuhighlight(menuid)
  455. C /*
  456. C ** \parambegin
  457. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  458. C ** \paramend
  459. C ** \blurb{This function returns the attributes of the highlighted menu item
  460. C ** to their original values. If no item is highlighted the function is
  461. C ** ignored.}
  462. C */
  463.        INTEGER menuid
  464.        external ptk_clearboxmenuhighlight 
  465. & !$PRAGMA  C(ptk_clearboxmenuhighlight)
  466.  
  467.        call ptk_clearboxmenuhighlight(%val(menuid))
  468.  
  469.        RETURN
  470.        END
  471.        
  472.        SUBROUTINE ptkf_inqpostedmenus(wsid, num, menuids, totalnum, err)
  473. C /*
  474. C ** \parambegin
  475. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  476. C ** \param{INTEGER}{size}{size of buffer}{IN}
  477. C ** \param{INTEGER}{menuids(*)}{list of posted menus}{OUT}
  478. C ** \param{INTEGER}{totalsize}{length of posted menus list}{OUT}
  479. C ** \param{INTEGER}{err}{error indicator}{OUT}
  480. C ** \paramend
  481. C ** \blurb{This function may be used to inquire the list of all menus
  482. C ** which are posted to workstation {\tt wsid}.}
  483. C */
  484.        INTEGER wsid, num, menuids(num), totalnum, err
  485.        external ptkc_inqpostedmenus !$PRAGMA C(ptkc_inqpostedmenus)
  486.  
  487.        call ptkc_inqpostedmenus(%val(wsid), %val(num), menuids, 
  488. & totalnum, err)
  489.  
  490.        RETURN
  491.        END
  492.        
  493.        SUBROUTINE ptkf_inqmenuids(num, menuids, totalnum, err)
  494. C /*
  495. C ** \parambegin
  496. C ** \param{INTEGER}{size}{size of buffer}{IN}
  497. C ** \param{INTEGER}{menuids(*)}{list of menus}{OUT}
  498. C ** \param{INTEGER}{totalsize}{length of menus list}{OUT}
  499. C ** \param{INTEGER}{err}{error indicator}{OUT}
  500. C ** \paramend
  501. C ** \blurb{This function may be used to obtain a list of all menus
  502. C ** in the PHIGS Toolkit menu store.}
  503. C */
  504.        INTEGER num, menuids(num), totalnum, err
  505.        external ptkc_inqmenuids !$PRAGMA C(ptkc_inqmenuids)
  506.  
  507.        call ptkc_inqmenuids(%val(num), menuids, totalnum, err)
  508.  
  509.        RETURN
  510.        END
  511.        
  512.        SUBROUTINE ptkf_inqmenustructid(menuid, menustid, err)
  513. C /*
  514. C ** \parambegin
  515. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  516. C ** \param{INTEGER}{menustid}{menu structure identifier}{OUT}
  517. C ** \param{INTEGER}{err}{error indicator}{OUT}
  518. C ** \paramend
  519. C ** \blurb{This function may be used to obtain the identifier
  520. C ** of a menu structure.}
  521. C */
  522.        INTEGER menuid, menustid, err
  523.        external ptk_inqmenustructid !$PRAGMA C(ptk_inqmenustructid)
  524.  
  525.        call ptk_inqmenustructid(%val(menuid), menustid, err)
  526.  
  527.        RETURN
  528.        END
  529.        
  530.        SUBROUTINE ptkf_inqmenuname(menuid, menuname, err)
  531. C /*
  532. C ** \parambegin
  533. C ** \param{INTEGER}{windid}{menu identifier}{IN}
  534. C ** \param{INTEGER}{name}{menu name}{OUT}
  535. C ** \param{INTEGER}{err}{error indicator}{OUT}
  536. C ** \paramend
  537. C ** \blurb{This function may be used to obtain the menu name 
  538. C ** for use in the pick filter.}
  539. C */
  540.        INTEGER menuid, menuname, err
  541.        external ptk_inqmenuname !$PRAGMA C(ptk_inqmenuname)
  542.       
  543.        call ptk_inqmenuname(%val(menuid), menuname, err)
  544.  
  545.        RETURN
  546.        END
  547.        
  548.        LOGICAL FUNCTION ptkf_inqfrontbackmenuid(wsid, frontid, backid,
  549. & err)
  550. C /*
  551. C ** \parambegin
  552. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  553. C ** \param{INTEGER}{frontstid}{front menu identifier}{OUT}
  554. C ** \param{INTEGER}{backstid}{back menu identifier}{OUT}
  555. C ** \param{INTEGER}{err}{error indicator}{OUT}
  556. C ** \paramend
  557. C ** \blurb{This function may be used to obtain the menu identifiers
  558. C ** of the front and back menus which are posted to workstation {\tt wsid}. 
  559. C ** These are the menus with the highest and lowest post priority.}
  560. C ** 
  561. C */
  562.        INTEGER wsid, frontid, backid, err
  563.        LOGICAL*1 ptk_inqfrontbackmenuid, ans
  564.        external ptk_inqfrontbackmenuid 
  565. & !$PRAGMA C(ptk_inqfrontbackmenuid)
  566.  
  567.        ans = ptk_inqfrontbackmenuid(%val(wsid), frontid, backid, err)
  568.        if (ans .eq. 1) then
  569.           ptkf_inqfrontbackmenuid = .TRUE.
  570.        else
  571.           ptkf_inqfrontbackmenuid = .FALSE.
  572.        endif
  573.  
  574.        RETURN
  575.        END
  576.  
  577.        SUBROUTINE ptkf_inqmenuposition(menuid, position, err)
  578. C /*
  579. C ** \parambegin
  580. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  581. C ** \param{REAL}{position(2)}{menu position}{OUT}
  582. C ** \param{INTEGER}{err}{error indicator}{OUT}
  583. C ** \paramend
  584. C ** \blurb{This function may be used to obtain the position of the
  585. C ** top-left corner of first menu item. The position is returned in the
  586. C ** range [0, 1].}
  587. C */
  588.        INTEGER menuid
  589.        REAL position(2)
  590.        INTEGER err
  591.        external ptk_inqmenuposition !$PRAGMA C(ptk_inqmenuposition)
  592.  
  593.        call ptk_inqmenuposition(%val(menuid), position, err)
  594.  
  595.        RETURN
  596.        END
  597.  
  598.        SUBROUTINE ptkf_inqboxmenuhighlightitem(menuid, item, err)
  599. C /*
  600. C ** \parambegin
  601. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  602. C ** \param{INTEGER}{item}{hightlight item number}{OUT}
  603. C ** \param{INTEGER}{err}{error indicator}{OUT}
  604. C ** \paramend
  605. C ** \blurb{This function may be used to obtain the item number of the
  606. C ** currently highlight box menu item.}
  607. C */
  608.        INTEGER menuid, item, err
  609.        external ptk_inqboxmenuhighlightitem 
  610. & !$PRAGMA C(ptk_inqboxmenuhighlightitem)
  611.  
  612.        call ptk_inqboxmenuhighlightitem(%val(menuid), item, err)
  613.  
  614.        RETURN
  615.        END
  616.  
  617.        SUBROUTINE ptkf_inqboxmenuattrs(menuid, menupath,
  618. & font, textcolour, intcolour, edgecolour, boxtlcolour, boxbrcolour, 
  619. & httextcolour, htintcolour, htedgecolour, err)
  620. C /*
  621. C ** \parambegin
  622. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  623. C ** \param{Ptxpath *}{menupath}{path of box menu (left, right, up, down)}{OUT}
  624. C ** \param{INTEGER}{font}{text font}{OUT}
  625. C ** \param{INTEGER}{textcolour}{colour index for text}{OUT}
  626. C ** \param{INTEGER}{intcolour}{colour index for interior}{OUT}
  627. C ** \param{INTEGER}{edgecolour}{colour index for edges}{OUT}
  628. C ** \param{INTEGER}{boxtlcolour}{colour index for top-left of box}{OUT}
  629. C ** \param{INTEGER}{boxcolour}{colour index for bottom-right of box}{OUT}
  630. C ** \param{INTEGER}{httextcolour}{colour index for highlight text}{OUT}
  631. C ** \param{INTEGER}{htintcolour}{colour index for highlight interior}{OUT}
  632. C ** \param{INTEGER}{htedgecolour}{colour index for highlight edges}{OUT}
  633. C ** \param{INTEGER}{err}{error indicator}{OUT}
  634. C ** \paramend
  635. C ** \blurb{This function may be used to obtain the boxmenu attribute
  636. C ** values for {\tt menuid}. These include the menu path, text font and
  637. C ** colour indicies.}
  638. C */
  639.        INTEGER menuid, menupath, font, textcolour, intcolour
  640.        INTEGER edgecolour, boxtlcolour, boxbrcolour
  641.        INTEGER httextcolour, htintcolour, htedgecolour, err
  642.        external ptk_inqboxmenuattrs
  643. & !$PRAGMA C(ptk_inqboxmenuattrs)
  644.  
  645.        call ptk_inqboxmenuattrs(%val(menuid), menupath,
  646. & font, textcolour, intcolour, edgecolour, boxtlcolour, 
  647. & boxbrcolour, httextcolour, htintcolour, htedgecolour, err)
  648.  
  649.        RETURN
  650.        END
  651.  
  652.        SUBROUTINE ptkf_createrotator(wsid, menuid, rottype, size, 
  653. & titlestr,  titleheight)
  654. C /*
  655. C ** \parambegin
  656. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  657. C ** \param{INTEGER}{menuid}{rotator identifier}{IN}
  658. C ** \param{INTEGER}{rottype}{rotator type}{IN}
  659. C ** \param{REAL}{size(2)}{rotator size}{IN}
  660. C ** \param{CHARACTER*(*)}{titlestr}{rotator title}{IN}
  661. C ** \param{REAL}{titleheight}{rotator title height}{IN}
  662. C ** \paramend
  663. C ** \blurb{This function creates a special form of user menu called a
  664. C ** rotator. Rotators consist of an arrangement of arrows and are useful
  665. C ** for defining rotation values and direction in a user interface.
  666. C ** There are three types of rotator available: 1D, 2D and 3D, and each
  667. C ** having an increasing number of arrows.}
  668. C */
  669.  
  670.        INTEGER wsid, menuid, rottype
  671.        REAL size(2)
  672.        CHARACTER*(*) titlestr
  673.        REAL titleheight
  674.        REAL*8 dptitleheight
  675.        CHARACTER*255 inbuf
  676.        external ptk_createrotator !$PRAGMA C(ptk_createrotator)
  677.  
  678.        inbuf = titlestr//'\0'
  679.        dptitleheight = titleheight
  680.        call ptk_createrotator(%val(wsid), %val(menuid), %val(rottype), 
  681. & size, inbuf, %val(dptitleheight))
  682.  
  683.        RETURN
  684.        END
  685.        
  686.        SUBROUTINE ptkf_setrotatortitle(menuid, titlestr)
  687. C /*
  688. C ** \parambegin
  689. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  690. C ** \param{CHARACTER*(*)}{titlestr}{title string of rotator banner}{IN}
  691. C ** \paramend 
  692. C ** \blurb{This function sets the title string of the rotator menu
  693. C ** to be {\tt titlestr}. The string is automatically scaled to fit
  694. C ** in the rotator title box.}
  695. C */
  696.        INTEGER menuid
  697.        CHARACTER*(*) titlestr
  698.        CHARACTER*255 inbuf
  699.        external ptk_setrotatortitle !$PRAGMA C(ptk_setrotatortitle)
  700.  
  701.        inbuf = titlestr//'\0'
  702.        call ptk_setrotatortitle(%val(menuid), inbuf)
  703.  
  704.        RETURN
  705.        END
  706.  
  707.        SUBROUTINE ptkf_setrotatorattrs(wsid, menuid, 
  708. & titlefont, titlecolour, arrowcolour, arrowedgecolour,
  709. & intcolour, edgecolour, bannercolour, 
  710. & boxtlcolour, boxbrcolour)
  711. C /*
  712. C ** \parambegin
  713. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  714. C ** \param{INTEGER}{menuid}{rotator identifier}{IN}
  715. C ** \param{INTEGER}{titlefont}{title font}{IN}
  716. C ** \param{INTEGER}{titlecolour}{title colour index}{IN}
  717. C ** \param{INTEGER}{arrowcolour}{arrow interior colour index}{IN}
  718. C ** \param{INTEGER}{arrowedgecolour}{arrow edge colour index}{IN}
  719. C ** \param{INTEGER}{intcolour}{rotator interior colour index}{IN}
  720. C ** \param{INTEGER}{edgecolour}{edge colour index}{IN}
  721. C ** \param{INTEGER}{bannercolour}{banner colour index}{IN}
  722. C ** \param{INTEGER}{boxtlcolour}{top-left colour index}{IN}
  723. C ** \param{INTEGER}{boxbrcolour}{bottom-right colour index}{IN}
  724. C ** \paramend
  725. C ** \blurb{This function sets the attribute values of a rotator menu.
  726. C ** The arrows are drawn within a box similar to that of box menu
  727. C ** items and the box has an area for a title string. All arrows
  728. C ** are drawn with the same colour values defined by {\tt arrowcolour}
  729. C ** for the interior and {\tt arrowedgecolour} for the outline.}
  730. C */
  731.        INTEGER wsid, menuid, titlefont
  732.        INTEGER titlecolour, arrowcolour, arrowedgecolour
  733.        INTEGER intcolour, edgecolour, bannercolour
  734.        INTEGER boxtlcolour, boxbrcolour
  735.        external ptk_setrotatorattrs
  736. & !$PRAGMA C(ptk_setrotatorattrs)
  737.  
  738.        call ptk_setrotatorattrs(%val(wsid), %val(menuid), 
  739. & %val(titlefont), %val(titlecolour), %val(arrowcolour),
  740. & %val(arrowedgecolour), %val(intcolour), 
  741. & %val(edgecolour), %val(bannercolour), 
  742. & %val(boxtlcolour), %val(boxbrcolour))
  743.  
  744.        RETURN
  745.        END
  746.  
  747.        SUBROUTINE ptkf_inqrotatortitle(menuid, len, titlestr, totlen,
  748. & err)
  749. C /*
  750. C ** \parambegin
  751. C ** \param{INTEGER}{menuid}{menu identifier}{IN}
  752. C ** \param{INTEGER}{len}{length of string}{IN}
  753. C ** \param{CHARACTER*(*)}{titlestr}{title string of rotator banner}{IN}
  754. C ** \param{INTEGER}{totlen}{actual length of string}{OUT}
  755. C ** \param{INTEGER}{err}{error indicator}{OUT}
  756. C ** \paramend 
  757. C ** \blurb{This function may be used to obtain the title string of a rotator
  758. C ** menu.}
  759. C */
  760.        INTEGER menuid, len
  761.        CHARACTER*(*) titlestr
  762.        INTEGER totlen, err
  763.        CHARACTER*255 inbuf
  764.        external ptk_inqrotatortitle !$PRAGMA C(ptk_inqrotatortitle)
  765.  
  766.        call ptk_inqrotatortitle(menuid, %val(len), titlestr, totlen,
  767. & err) 
  768.        totlen = totlen - 1
  769.        if (len .le. 255) then
  770.          titlestr = inbuf(1:totlen)
  771.        endif
  772.  
  773.        RETURN
  774.        END
  775.  
  776.        SUBROUTINE ptkf_inqrotatorattrs(menuid, 
  777. & titlefont, titlecolour, arrowcolour, arrowedgecolour, 
  778. & intcolour, edgecolour, bannercolour, boxtlcolour, 
  779. & boxbrcolour, err)
  780. C /*
  781. C ** \parambegin
  782. C ** \param{INTEGER}{menuid}{rotator identifier}{IN}
  783. C ** \param{INTEGER}{titlefont}{title font}{OUT}
  784. C ** \param{INTEGER}{titlecolour}{title colour index}{OUT}
  785. C ** \param{INTEGER}{arrowcolour}{arrow interior colour index}{OUT}
  786. C ** \param{INTEGER}{arrowedgecolour}{arrow edge colour index}{OUT}
  787. C ** \param{INTEGER}{intcolour}{rotator interior colour index}{OUT}
  788. C ** \param{INTEGER}{edgecolour}{edge colour index}{OUT}
  789. C ** \param{INTEGER}{bannercolour}{banner colour index}{OUT}
  790. C ** \param{INTEGER}{boxtlcolour}{top-left colour index}{OUT}
  791. C ** \param{INTEGER}{boxbrcolour}{bottom-right colour index}{OUT}
  792. C ** \param{INTEGER}{err}{error indicator}{OUT}
  793. C ** \paramend
  794. C ** \blurb{This function may be used to obtain the attribute values of
  795. C ** a rotator menu.}
  796. C */
  797.        INTEGER menuid, titlefont, titlecolour, arrowcolour
  798.        INTEGER arrowedgecolour, intcolour
  799.        INTEGER edgecolour, bannercolour, boxtlcolour
  800.        INTEGER boxbrcolour, err
  801.        external ptk_inqrotatorattrs !$PRAGMA C(ptk_inqrotatorattrs)
  802.  
  803.        call ptk_inqrotatorattrs(%val(menuid), 
  804. & titlefont, titlecolour, arrowcolour, arrowedgecolour, 
  805. & intcolour, edgecolour, bannercolour, boxtlcolour, 
  806. & boxbrcolour, err)
  807.  
  808.        RETURN
  809.        END
  810.        
  811. C     end of menu.f
  812.